perm filename SMALLX[NEW,LCS] blob
sn#148547 filedate 1975-03-06 generic text, type T, neo UTF8
21600 SUBROUTINE UNPACK(M,N,I)
21700 COMMON/LL/L
21800 C L IS FOR VIS. OR INVIS. LINES.
21900 N=I
22000 L=2
22100 M=N/100000000
22200 IF(M.EQ.0)GO TO 2
22300 L=3
22400 N=N-100000000*M
22500 2 M=N/10000
22600 N=MOD(N,10000)
22700 IF(M.GT.1000)M=1000-M
22800 IF(N.GT.1000)N=1000-N
22900 END
23000
23100 FUNCTION ROFF(R)
23200 S=.5
23300 IF(R)S=-S
23400 ROFF=R+S
23500 RETURN
23600 END
23700
23800
23900 C************** NOIR, RJBX, CENTX ***************
24000 SUBROUTINE NOIR(RMINI)
24100 C BLACKS IN NOTES
24200 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(12),B,C,KC,D,N,JY,M,L
24300 COMMON/PLTR/IPLT,RHT,DIS /XRN/IRN(4000)
24400 EQUIVALENCE (PRE,IRN(1))
24500 DATA BL/7.5/,BH/6.7/
24600 C ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
24700 IPOS=ROFF(RJQ(1)*DIS)
24800 CC IF(RMINI.LT..9)IPOS=IPOS+1
24900 JPOS=ROFF(CENTR*RHT)
25000 IF(-RMINI.EQ.PRE)GO TO 10
25100 PRE=-RMINI
25200 CC D=.25*RMINI
25250 D=.25
25300 B=BH*RMINI*RHT
25400 E=RMINI*DIS
25500 A=BL*E
25600 IC=A
25700 A=A*A
26200 E=-B/4.
26300 K=B
26400 B=B*B
26500 C USES EQUATION FOR ELLIPSE
26600 N=1
26700 NX=2
26800 6 DO 1 J=-K,K
26900 Y=J*J
27000 X=SQRT(A-(A*Y)/B)
27100 L=E-X
27200 M=X+E
27300 C THE TWO SIDES OF THE LINE
27400 IF(N)CALL EXCH(L,M)
27500 IRN(NX)=L
27600 IRN(NX+1)=M
27700 C C IS VERTICLE POS.
27800 NX=NX+2
27900 E=E+D
28000 C E IS TO TILT IT.
28100 1 N=-N
28200 10 CALL PLOT(IPOS+3,JPOS,3)
28300 N=2
28400 C 1ST LOC. OF ARRAY HAS "PRE"
28500 L=IPOS+IC
28600 DO 11 M=-K,K
28700 J=M+JPOS
28800 CALL PLOT(L+IRN(N),J,2)
28900 CALL PLOT(L+IRN(N+1),J,2)
29000 11 N=N+2
29100 END
29200
32200 CC SUBROUTINE RJBX(R)
32300 CC COMMON Q(4),R3,RJQ(39)/STF/RSTFAC(8),RSTJ2
32400 CC R3=R3+R*RSTJ2
32500 CC END
32600
32700 CC SUBROUTINE CENTX
32800 CC COMMON A,B,CENTR,D,E,R4,R(38) /STF/RSTFAC(8),RSTJ2
32900 CC 1 /POSI/STFF(8),JJ2,POS
33000 CC CENTR=POS-18.*RSTJ2+AMOD(R4,100.0)*RSTJ2*7.
33100 CC END
33200 C******** THE ABOVE ARE NOW IN SMALL.FAI (3/75)
33210
33300 C****** 7, STF, POS, HGT, NUM OF SHARPS OR FLATS(+ OR -), CLEF
33400 C ( CLEF = TREB,0 BASS,1 ALT,2 TEN,3 )
33500 SUBROUTINE KSIG
33600 C FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
33700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(17),T,S,Z/STF/RSTFAC(-3/4),RSTJ2
33800 EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J6,JQ(4))
33850 1,(R6,RJQ(4))
33900
34000 JA=9
34100 C USES THIS KEY NUM IN NOTWRT
34200 C COUNTER
34300 IZ=IABS(J5)
34400 C NUMBER OF CALLS ON NOTWRT
34500 C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
34600 JW=1
34610 R6=0
34700 IF(J5.GT.0)JW=2
34800 C THE CODE FOR FLAT OR SHARP
34900 5333 CLEF=-(J6+1)
35000 C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
35100 C CLEF NOW SET IN MAIN PROG.
35200 C IF NO CLEF GIVEN, TREBLE IS USED.
35300 T=10.
35400 IF(CLEF.LT.-2.)T=11.
35500 S=CLEF+4.
35600 IF(CLEF.EQ.-4)S=-1.
35700 IF(J5.LT.0)GO TO 253
35800 W=-3.
35900 YY=4.
36000 Z=11.
36100 C SHARPS
36200 GO TO 353
36300 253 W=3.
36400 YY=-4.
36500 Z=7.
36600 C FLATS
36700 353 N=1
36750 Z=Z+R4
36800 RX=JQ(1)
36900 RA=0
37000 C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
37100 DO 553 KA=1,IZ
37200 J5=JW
37300 RJQ(1)=RX+RA
37400 RA=RA+13.*RSTJ2
37500 C MOVES OVER FOR NEXT ACCI.
37600 RD=Z
37700 R4=Z
37800 IF(CLEF.NE.-1.)GO TO 7
37900 IF(R4.GT.12.)R4=R4-7.
38000 GO TO 9
38100 7 R4=R4-S
38200 IF(R4.GT.T)R4=R4-7.
38300 C ABOVE ARRANGES VERT. POS OF ACCIS.
38400 9 J4=R4
38500 C FOR VERT. POS. IN 'DRWNT' (WHEN PLOTTING.)
38600 CALL CENTX
38700 CALL NOTWRT
38800 Z=RD+W
38900 IF(N)Z=RD+YY
39000 553 N=-N
39100 END